perm filename PP.2[EAL,HE]3 blob
sn#704699 filedate 1983-03-30 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00006 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 {$NOMAIN Page Printer routines (used by everything) }
C00010 00003 { Externally defined routines from elsewhere: }
C00011 00004 (* Line allocation routines: getLine, relLine *)
C00016 00005 (* Page Printer routines: ppGlitch, ppChar, ppOutNow, ppLine *)
C00020 00006 (* Page Printer routines: pp5, pp10(L), pp20(L), ppInt, ppReal, ppStrng, ppDelChar, ppDtype *)
C00024 ENDMK
C⊗;
{$NOMAIN Page Printer routines (used by everything) }
const
(* Constants from EDIT *)
maxLines = 40;
maxPPLines = 30;
maxBpts = 25;
maxTBpts = 20; (* max could be exceeded by huge case stmnt *)
listinglength = 4000; (* Length of Listingarray *)
(* Random type declarations for OMSI/SAIL compatibility *)
type
byte = 0..255; (* doesn't really belong here, but... *)
ascii = char;
atext = text;
vectorp = ↑integer;
transp = ↑integer;
strngp = ↑strng;
eventp = ↑integer;
framep = ↑integer;
statementp = ↑integer;
varidefp = ↑integer;
nodep = ↑integer;
identp = ↑integer;
tokenp = ↑integer;
reswordp = ↑integer;
pdbp = ↑integer;
envheaderp = ↑integer;
enventryp = ↑integer;
environp = ↑integer;
cmoncbp = ↑integer;
messagep = ↑integer;
linerecp = ↑linerec;
dump = ↑integer;
token = array[1..4] of integer;
cursorp = array[1..4] of integer;
cstring = packed array [1..10] of ascii;
c4str = packed array [1..4] of ascii;
c5str = packed array [1..5] of ascii;
c20str = packed array [1..20] of ascii;
linestr = packed array [1..130] of ascii;
datatypes = (pconstype, varitype, svaltype, vectype, rottype, transtype,
frametype, eventtype, strngtype, labeltype, proctype, arraytype,
reftype, valtype, cmontype, nulltype, undeftype,
dimensiontype, mactype, macargtype, freevartype);
scalar = real;
strng = record
next: strngp;
ch: cstring;
end;
linerec = record
next: linerecp;
start,length: integer
end;
listingarray = packed array [0..listinglength] of ascii;
(* global variables *)
var
(* from EDIT *)
listing: listingarray; (* first 150 chars are used by expression editor *)
(* next 40 by header & trailer lines *)
{*} cursorStack: array [1..15] of cursorp; {These are BIG records! }
lbuf: array [1..160] of ascii;
ppBuf: array [1..100] of ascii;
lines: array [1..maxLines] of linerecp; (* what's on the screen + some *)
ppLines: array [1..maxPPLines] of linerecp; (* for page printer *)
marks: array [1..20] of integer;
reswords: array [0..26] of reswordp;
idents: array [0..26] of identp;
macrostack: array [1..10] of tokenp;
curmacstack: array [1..10] of varidefp;
screenheight,dispHeight: integer;
ppBufp,oppBufp,ppOffset,ppSize,nmarks: integer;
lbufp,cursor,ocur,cursorLine,fieldnum,lineNum,findLine,pcLine: integer;
firstDline,topDline,botDline,firstLine,lastLine,curLine: integer;
freeLines,oldLines: linerecp;
sysVars: varidefp;
dProg: statementp;
curBlock, newDeclarations, findStmnt: statementp;
macrodepth: integer;
filedepth, errCount, sCursor: integer;
curChar, maxChar, curFLine, curPage: integer;
nodim, distancedim, timedim, angledim,
forcedim, torquedim, veldim, angveldim: varidefp;
fvstiffdim, mvstiffdim: nodep;
pnode: nodep;
smartTerminal: boolean; (* true = insert/delete, false = redraw line *)
setUp,setExpr,setCursor,dontPrint,outFilep,collect,fParse,sParse,
eofError,endOfLine,backup,expandmacros,flushcomments,checkDims,
shownLine: boolean;
curtoken: token;
file1,file2,file3,file4,file5,outFile: atext;
bpts: array [1..maxBpts] of statementp; (* debugging crap *)
tbpts: array [1..maxTBpts] of statementp;
debugPdbs: array [0..10] of pdbp;
nbpts,ntbpts,debugLevel: integer;
eCurInt: pdbp;
STLevel: integer; (* set by GO *)
singleThreadMode,tSingleThreadMode: boolean;
(* from INTERP *)
inputLine: array [1..20] of ascii;
talk: text; (* for using the speech synthesizer *)
curInt, activeInts, readQueue, allPdbs: pdbp;
sysEnv: envheaderp;
clkQueue: nodep;
allEvents: eventp;
etime: integer; (* used by eval *)
curtime: integer; (* who knows where this will get updated - an ast? *)
stime: integer; (* used for clock queue on 10 *)
msg: messagep; (* for AL-ARM interaction *)
inputp: integer; (* current offset into inputLine array above *)
resched, running, escapeI, iSingleThreadMode: boolean;
msgp: boolean; (* flag set if any messages pending *)
inputReady: boolean;
(* various constant pointers *)
xhat,yhat,zhat,nilvect: vectorp;
niltrans: transp;
gpark, rpark: transp; (* arm park positions *)
(* various device & variable pointers *)
speedfactor: enventryp;
garm: framep;
{ Externally defined routines from elsewhere: }
(* From EPUT *)
procedure putReal(s: real); external;
(* From DISP *)
procedure outLine(line,col,start,length: integer); external;
procedure delLine(line,num: integer); external;
procedure beep; external;
procedure showCursor(line,col: integer); external;
(* Line allocation routines: getLine, relLine *)
function getLine(length: integer): linerecp; external;
function getLine;
var f,fo,fp: linerecp; b: boolean;
begin
if length < 10 then length := 10; (* so we don't get too fragmented *)
f := freeLines;
fo := nil;
b := false;
while not b do (* Find a long enough free line *)
if f = nil then b := true
else if f↑.length >= length then b := true
else begin fo := f; f := f↑.next end;
if f <> nil then
begin
if f↑.length < (length + 8) then
begin (* use entire free line *)
if fo = nil then freeLines := f↑.next (* splice out old free line *)
else fo↑.next := f↑.next;
fp := f;
end
else
begin (* split free line in two parts *)
if oldLines = nil then new(fp) (* get a new line *)
else begin fp := oldLines; oldLines := fp↑.next; end;
fp↑.start := f↑.start;
fp↑.length := length;
f↑.start := f↑.start + length;
f↑.length := f↑.length - length;
end;
end
else
begin
(* *** compact screen array??? *** *)
beep; writeln('Gack - no more room in listing array!!!'); break(output); beep;
(* *** do something intelligent here??? *** *)
if oldLines = nil then new(fp) (* get a new line *)
else begin fp := oldLines; oldLines := fp↑.next; end;
fp↑.start := 1; (* this will clobber line editor, but... *)
fp↑.length := length;
beep;
end;
fp↑.next := nil;
getLine := fp;
end;
procedure relLine(l: linerecp); external;
procedure relLine;
var f,fo: linerecp; b: boolean;
begin
if l <> nil then
if l↑.length > 0 then
begin
f := freeLines;
fo := nil;
b := false;
while not b do (* Find a long enough free line *)
if f = nil then b := true
else if f↑.start >= l↑.start then b := true
else begin fo := f; f := f↑.next end;
b := true;
if fo <> nil then
with fo↑ do (* try to merge with last line *)
if (start + length) = l↑.start then
begin length := length + l↑.length; b := false end;
if f <> nil then
if (l↑.start + l↑.length) = f↑.start then (* try to merge with next line *)
if b then
begin (* merge with next line *)
f↑.start := l↑.start;
f↑.length := f↑.length + l↑.length;
b := false
end
else
begin (* can merge last & next now *)
fo↑.length := fo↑.length + f↑.length;
fo↑.next := f↑.next;
f↑.next := oldLines; (* add it to free line queue *)
oldLines := f;
end;
if b then
begin (* need to add to free line list *)
l↑.next := f;
if fo <> nil then fo↑.next := l else freeLines := l;
end
else begin l↑.next := oldLines; oldLines := l end; (* release line pntr *)
end;
end;
(* Page Printer routines: ppGlitch, ppChar, ppOutNow, ppLine *)
procedure ppGlitch; external;
procedure ppGlitch;
var i,j: integer;
procedure clearLine(i: integer); (* Copied from EAUX1A *)
var ch: ascii;
begin
ch := listing[1];
listing[1] := ' ';
outLine(i,1,1,1);
listing[1] := ch;
end;
begin
if ppbufp > 0 then (* If anything in buffer *)
begin
ppLines[ppOffset] := getLine(ppBufp); (* get a line to store chars in *)
with ppLines[ppOffset]↑ do
begin
for i := 1 to ppBufp do listing[start+i-1] := ppBuf[i]; (* copy line *)
for i := ppBufp to length-1 do listing[start+i] := chr(0);
outLine(dispHeight+ppOffset+1,oppBufp+1,start+oPPbufp,ppBufp-oppBufp);
end
end
else
begin
ppLines[ppOffset] := nil;
clearLine(dispHeight+ppOffset+1);
end;
PPbufp := 0;
oPPbufp := 0;
if ppOffset >= ppSize then
begin (* need to glitch page printer *)
if ppsize < 5 then j := 1 (* determine glitch size *)
else if ppsize < 7 then j := 2
else if ppsize < 11 then j := 3
else j := 5;
for i := 1 to j do relLine(ppLines[i]);
for i := 1 to ppSize-j do ppLines[i] := ppLines[i+j];
for i := ppSize-j+1 to ppSize do ppLines[i] := nil;
if smartTerminal then delLine(dispHeight+2,j)
else
begin
for i := 1 to ppSize do
if ppLines[i] <> nil then
with ppLines[i]↑ do
outLine(dispHeight+i+1,1,start,length) (* re-draw top lines *)
else clearLine(dispHeight+i+1);
end;
ppOffset := ppOffset - j + 1;
end
else ppOffset := ppOffset + 1; (* just move to next line *)
end;
procedure ppChar(ch: ascii); external;
procedure ppChar;
begin
if ch = chr(15B) then ppGlitch (* scroll up page printer *)
else if ch <> chr(12B) then (* flush linefeeds *)
begin (* add character to pp buffer *)
if ppBufp >= 80 then ppGlitch;
ppBufp := ppBufp + 1;
ppBuf[ppBufp] := ch;
end;
end;
procedure ppOutNow; external;
procedure ppOutNow;
var i: integer;
begin
for i := oppBufp+1 to ppBufp do listing[i-oppBufp] := ppBuf[i];
outLine(dispHeight+ppOffset+1,oppBufp+1,1,ppBufp-oppBufp);
oppBufp := ppBufp;
showCursor(dispHeight+ppOffset+1,ppBufp+1);
end;
procedure ppLine; external; (* Does the same as ppGlitch *)
procedure ppLine;
begin
ppChar(chr(15B)); (* cr *)
end;
(* Page Printer routines: pp5, pp10(L), pp20(L), ppInt, ppReal, ppStrng, ppDelChar, ppDtype *)
procedure pp5(ch: c5str; length: integer); external;
procedure pp5;
var i: integer;
begin
for i := 1 to length do ppChar(ch[i]);
end;
procedure pp10(ch: cstring; length: integer); external;
procedure pp10;
var i: integer;
begin
for i := 1 to length do ppChar(ch[i]);
end;
procedure pp10L(ch: cstring; length: integer); external;
procedure pp10L;
begin
if ppBufp > 0 then ppLine;
pp10(ch,length);
end;
procedure pp20(ch: c20str; length: integer); external;
procedure pp20;
var i: integer;
begin
for i := 1 to length do ppChar(ch[i]);
end;
procedure pp20L(ch: c20str; length: integer); external;
procedure pp20L;
begin
if ppBufp > 0 then ppLine;
pp20(ch,length);
end;
procedure ppInt(i: integer); external;
procedure ppInt;
var j,k: integer; n: array [1..9] of integer;
begin
for j := 1 to 9 do (* get individual digits *)
begin n[j] := i mod 10; i := i div 10 end;
j := 9;
while (j > 1) and (n[j] = 0) do j := j - 1; (* ignore leading zeros *)
for k := j downto 1 do ppChar(chr(ord('0')+n[k])); (* print it *)
end;
procedure ppReal(r: real); external;
procedure ppReal;
var i,j: integer;
begin
j := lbufp;
putReal(r);
ppChar(' ');
for i := j+1 to lbufp do ppChar(lbuf[i]); (* print it *)
lbufp := j; (* restore old line buf pntr *)
end;
procedure ppStrng(length: integer; s: strngp); external;
procedure ppStrng;
var i,j: integer;
begin
j := 1;
for i := 1 to length do
begin
ppChar(s↑.ch[j]);
if j = 10 then begin j := 1; s := s↑.next; end
else j := j + 1;
end;
end;
procedure ppDelChar; external; (* for use by INTERP *)
procedure ppDelChar;
begin
if ppBufp > 0 then
begin
ppBuf[ppBufp] := ' ';
listing[1] := ' ';
outLine(dispHeight+ppOffset+1,ppBufp,1,1);
ppBufp := ppBufp - 1;
oppBufp := ppBufp;
showCursor(dispHeight+ppOffset+1,ppBufp+1);
end;
end;
procedure ppDtype(d: datatypes); external;
procedure ppDtype;
begin
case d of
svaltype: pp10('scalar ',6);
vectype: pp10('vector ',6);
rottype: pp5('rot ',3);
transtype: pp5('trans',5);
frametype: pp5('frame',5);
eventtype: pp5('event',5);
strngtype: pp10('string ',6);
otherwise {do nothing - should not happen};
end;
end;